perm filename QBALL.OLD[CRE,BGB] blob
sn#067717 filedate 1973-10-25 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00016 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 BEGIN "QBALL"
C00006 00003 α QUE-BALLS
C00008 00004 α FILE OPENING CEREMONIES -------------------------------------------
C00009 00005 α IRON TRIANGLE - CAMERA LOCUS SOLVER -------------------------------
C00011 00006 SUBR MKROT
C00012 00007 SUBR TRANSFORM
C00013 00008 SUBR SHOW
C00015 00009 α ...THE SHOW CONTINUED
C00017 00010 SUBR MODIFY
C00020 00011 α CRE LINKS & DATUMS
C00022 00012 SUBR INERTIA
C00024 00013
C00026 00014 SUBR PDPY (ITG PGN) α POLYGON DISPLAY
C00028 00015 SUBR IDPY (ITG IMG) α IMAGE DISPLAY
C00030 00016 α MAIN EXECUTION ----------------------------------------------------
C00031 ENDMK
C⊗;
BEGIN "QBALL"
REQUIRE "ABBREV[SYS,BGB]" SOURCE_FILE;
REQUIRE "SAITRG[SYS,BGB]" SOURCE_FILE;
REQUIRE "DPYIII[SYS,BGB]" SOURCE_FILE;
SAFE ITG ARRAY DPYBUF[0:1500];
α CAMERA;
REAL PAN,TILT,SWING; α CAMERA ORIENTATION;
REAL CX,CY,CZ; α CAMERA LOCATION;
REAL PDX,PDY,FOCAL; α PIXEL SIZE & LENS FOCAL LENGTH;
REAL ASPECT;
REAL RPA,CPA; α IMAGE LOCUS OF PRINCIPLE RAY;
REAL IX,IY,IZ;
REAL JX,JY,JZ;
REAL KX,KY,KZ;
REAL TRNDEL,ROTDEL;
α QUE-BALLS;
REAL ARRAY XWC,YWC,ZWC[1:16]; α WORLD COORDINATES;
REAL ARRAY XCC,YCC,ZCC[1:16]; α PREDICTED CAMERA COORDINATES;
REAL ARRAY XPP,YPP,ZPP[1:16]; α PREDICTED IMAGE COORDINATES;
REAL ARRAY XDC,YDC,ZDC[1:16]; α DISPLAY COORDINATES;
REAL ARRAY PRROW,PRCOL[1:16]; α PERCEIVED ROW & COL;
REAL ARRAY PRXCC,PRYCC[1:16]; α PERCEIVED CAMERA COORDINATES;
REAL ARRAY PRXPP,PRYPP[1:16]; α PERCEIVED IMAGE COORDINATES;
REAL ARRAY PRXDC,PRYDC[1:16]; α PERCEIVED DISPLAY COORDINATES;
REAL ARRAY RADIUS[1:16]; α PERCEIVED RADIUS;
ITG ARRAY SNODE[1:16]; α QUE BALL SHAPE NODES;
REAL MAG,ORGX,ORGY;ITG CNT;
α ORBIT PARAMETERS;
REAL ORBROW,ORBCOL;
REAL ORBMXX,ORBMYY,ORBPXY;
REAL ORBAREA,ORBARC;
REAL ORBA,ORBB;
α FILE OPENING CEREMONIES -------------------------------------------;
INTEGER SIZE,ORIG;
OPEN(1,"DSK",8,3,0,0,0,0);
LOOKUP(1,"QBALL.CRE",0);
SIZE ← WORDIN(1);
MAG ← 3.5;
BEGIN
REAL C,S;ITG I;
RPA ← 108; CPA ← 144;
CX ← 10; CY ← -30; CZ ← 20;
PAN ← 14*π/180; TILT ← 57*π/180; SWING ← 5*π/180;
MAG ← 32/9; FOCAL ← 21000;
PDX ← 38.78; PDY ← 40.0;
C ← COS(-π/8); S ← SIN(-π/8);
XWC[1] ← 6; YWC[1] ← 0; ZWC[1] ← 0;
FOR I←2 THRU 16 DO
⊂ XWC[I] ← C*XWC[I-1] - S*YWC[I-1];
YWC[I] ← S*XWC[I-1] + C*YWC[I-1];
ZWC[I]←0; ⊃;
END;
BEGIN "MAIN"
α IRON TRIANGLE - CAMERA LOCUS SOLVER -------------------------------;
REAL ARRAY P1,P2,P3,COSANG[1:3],V[1:10,1:3];
REQUIRE "LS1V3P.REL" LOAD_MODULE;
EXTERNAL ITG PROCEDURE LS1V3P(REAL ARRAY V,P1,P2,P3,COSANG);
REAL SUBR DOTVEC(ITG I,J);
BEGIN "DOTVEC"
REAL X1,Y1,Z1,X2,Y2,Z2,R1,R2,ZCOS;
X1 ← XCC[I]; Y1 ← YCC[I]; Z1 ← ZCC[I];
X2 ← XCC[J]; Y2 ← YCC[J]; Z2 ← ZCC[J];
R1 ← SQRT(X1*X1 + Y1*Y1 + Z1*Z1);
R2 ← SQRT(X2*X2 + Y2*Y2 + Z2*Z2);
ZCOS←(X1*X2 + Y1*Y2 + Z1*Z2) / (R1*R2);
RETURN(ZCOS);
END "DOTVEC";
SUBR LSCAM (ITG I,K,J);
BEGIN "LSCAM"
ITG M,N;
α IRON TRIANGLE - KNOWN WORLD LOCI;
P1[1]←XWC[I]; P2[1]←XWC[J]; P3[1]←XWC[K];
P1[2]←YWC[I]; P2[2]←YWC[J]; P3[2]←YWC[K];
P1[3]←ZWC[I]; P2[3]←ZWC[J]; P3[3]←ZWC[K];
α IRON TRIPOD - KNOW ANGLES BETWEEN CAMERA RAYS;
COSANG[1] ← DOTVEC(J,K);
COSANG[2] ← DOTVEC(I,K);
COSANG[3] ← DOTVEC(I,J);
α THROW THE SHIT AT THE FAN;
M ← LS1V3P(V,P1,P2,P3,COSANG);
OUTSTR(9&CVS(M)&" CAMERA SOLUTIONS."&↓);
FOR N←1 THRU M DO
OUTSTR(9&CVG(V[N,1])&9&CVG(V[N,2])&9&CVG(V[N,3])&↓);
INCHRW;
END "LSCAM";
SUBR MKROT;
BEGIN "MKROT"
REAL RR;
REAL C_PAN,S_PAN,C_TILT,S_TILT,C_SWING,S_SWING;
C_PAN ← COS(PAN); S_PAN ← SIN(PAN);
C_TILT ← COS(TILT); S_TILT ← SIN(TILT);
C_SWING ← COS(SWING); S_SWING ← SIN(SWING);
IX ← C_PAN*C_SWING - S_PAN*C_TILT*S_SWING;
IY ← S_PAN*C_SWING + C_PAN*C_TILT*S_SWING;
IZ ← S_TILT*S_SWING;
JX ← -C_PAN*S_SWING - S_PAN*C_TILT*C_SWING;
JY ← -S_PAN*S_SWING + C_PAN*C_TILT*C_SWING;
JZ ← S_TILT*C_SWING;
KX ← S_PAN*S_TILT;
KY ← -C_PAN*S_TILT;
KZ ← C_TILT;
END "MKROT";
SUBR TRANSFORM;
BEGIN "TRANSFORM"
ITG I;
FOR I←1 THRU 16 DO
BEGIN
REAL X,Y,Z,SX,SY;
α WC → CC WORLD LOCII PREDICTED;
X ← XWC[I] - CX;
Y ← YWC[I] - CY;
Z ← ZWC[I] - CZ;
XCC[I] ← X*IX + Y*IY + Z*IZ;
YCC[I] ← X*JX + Y*JY + Z*JZ;
ZCC[I] ← X*KX + Y*KY + Z*KZ;
α CC → PP;
SX ← -FOCAL/PDX;
SY ← -FOCAL/PDY;
XPP[I] ← SX * XCC[I] / ZCC[I];
YPP[I] ← SY * YCC[I] / ZCC[I];
α PP → DC;
XDC[I] ← MAG * (XPP[I]+(CPA-144));
YDC[I] ← MAG * (YPP[I]+(RPA-108));
END;
END "TRANSFORM";
SUBR SHOW;
BEGIN "SHOW"
ITG I,X,Y;DPYSET(DPYBUF);
DPYBIG(1);
AIVECT(400,480);DPYSST("PAN "&CVS(PAN*180/π+0.5));
AIVECT(400,455);DPYSST("TILT "&CVS(TILT*180/π+0.5));
AIVECT(400,430);DPYSST("SWING "&CVS(SWING*180/π+0.5));
AIVECT(400,405);DPYSST("ROTDEL "&CVS(ROTDEL*180/π+0.5));
AIVECT(-400,380+40);DPYSST(CVG(IX)&9&CVG(IY)&9&CVG(IZ));
AIVECT(-400,350+40);DPYSST(CVG(JX)&9&CVG(JY)&9&CVG(JZ));
AIVECT(-400,320+40);DPYSST(CVG(KX)&9&CVG(KY)&9&CVG(KZ));
AIVECT(400,375);DPYSST("CX = "&CVG(CX));
AIVECT(400,350);DPYSST("CY = "&CVG(CY));
AIVECT(400,325);DPYSST("CZ = "&CVG(CZ));
AIVECT(400,300);DPYSST("TRNDEL "&CVG(TRNDEL));
AIVECT(400,250);DPYSST("PDX = "&CVG(PDX));
AIVECT(400,225);DPYSST("PDY = "&CVG(PDY));
AIVECT(400,200);DPYSST("FOCAL = "&CVG(FOCAL));
AIVECT(400,150);DPYSST("RPA = "&CVG(RPA));
AIVECT(400,125);DPYSST("CPA = "&CVG(CPA));
α ...THE SHOW CONTINUED;
DPYBIG(1);
FOR I←1 THRU 16 DO
IF ZCC[I]≤0 ∧ ABS(XDC[I])≤511 ∧ ABS(YDC[I])≤511 THEN
BEGIN
X ← XDC[I];Y ← YDC[I];
AIVECT(X-7,Y-7); AVECT(X+7,Y+7);
AIVECT(X+7,Y-7); AVECT(X-7,Y+7);
AIVECT(X,Y);DPYSST(CVS(I));
END;
X ← MAG*(ORBCOL-144); Y ← MAG*(108-ORBROW);
AIVECT(X-5,Y); AVECT(X+5,Y);
AIVECT(X,Y-5); AVECT(X,Y+5);
AIVECT(X,Y);
AVECT( X + MAG*ORBA*COS(ORBARC),
Y + MAG*ORBA*SIN(ORBARC));
DPYSST(CVS(180*ORBARC/π+0.5));
AIVECT(X,Y);
AVECT( X + MAG*ORBB*COS(ORBARC+π/2),
Y + MAG*ORBB*SIN(ORBARC+π/2));
DPYSST(CVS(180*ACOS(ORBB/ORBA)/π+0.5));
FOR I←1 STEP 4 UNTIL 8 DO
⊂ AIVECT(PRXDC[I],PRYDC[I]);AVECT(PRXDC[I+8],PRYDC[I+8]);⊃;
DPYOUT(1);
END "SHOW";
SUBR MODIFY;
BEGIN "MODIFY"
ITG CHR,CTRL,META;
CHR ← INCHRW;
CTRL ← CHR LAND '200;
META ← CHR LAND '400;
CHR ← CHR LAND '177;
IF CHR="Q" THEN ⊂ STRING STR;OUTSTR(" #");
STR←INCHWL;LSCAM(INTSCAN(STR,CHR),
INTSCAN(STR,CHR),INTSCAN(STR,CHR));CHR←0;OUTCHR("*");⊃;
IF (CTRL∧¬META) THEN
BEGIN
IF CHR="/" THEN ROTDEL ← ROTDEL/2 ELSE
IF CHR="\" THEN ROTDEL ← ROTDEL*2 ELSE
IF CHR=";" THEN TILT ← TILT-ROTDEL ELSE
IF CHR=":" THEN TILT ← TILT+ROTDEL ELSE
IF CHR="(" THEN PAN ← PAN -ROTDEL ELSE
IF CHR=")" THEN PAN ← PAN +ROTDEL ELSE
IF CHR="-" THEN SWING ← SWING - ROTDEL ELSE
IF CHR="*" THEN SWING ← SWING + ROTDEL;
END;
IF ¬(CTRL∨META) THEN
BEGIN
IF CHR="/" THEN TRNDEL ← TRNDEL/2 ELSE
IF CHR="\" THEN TRNDEL ← TRNDEL*2 ELSE
IF CHR=";" THEN CX ← CX-TRNDEL ELSE
IF CHR=":" THEN CX ← CX+TRNDEL ELSE
IF CHR="(" THEN CY ← CY-TRNDEL ELSE
IF CHR=")" THEN CY ← CY+TRNDEL ELSE
IF CHR="-" THEN CZ ← CZ-TRNDEL ELSE
IF CHR="*" THEN CZ ← CZ+TRNDEL;
END;
IF CTRL∧META THEN
BEGIN
IF CHR=";" THEN CPA ← CPA-TRNDEL ELSE
IF CHR=":" THEN CPA ← CPA+TRNDEL ELSE
IF CHR="(" THEN RPA ← RPA+TRNDEL ELSE
IF CHR=")" THEN RPA ← RPA-TRNDEL;
END;
IF META∧¬CTRL THEN
BEGIN
IF CHR=";" THEN PDX ← PDX-TRNDEL ELSE
IF CHR=":" THEN PDX ← PDX+TRNDEL ELSE
IF CHR="(" THEN PDY ← PDY-TRNDEL ELSE
IF CHR=")" THEN PDY ← PDY+TRNDEL ELSE
IF CHR="-" THEN FOCAL ← FOCAL-TRNDEL*1000 ELSE
IF CHR="*" THEN FOCAL ← FOCAL+TRNDEL*1000;
END;
END "MODIFY";
α CRE LINKS & DATUMS;
SAFE ITG ARRAY NODE[0:SIZE];
α DECLARE CRE LINKS;
DEFINE CW(Q) = "(NODE[Q+0]LSH -18)";
DEFINE CCW(Q) = "(NODE[Q+0]LAND '777777)";
DEFINE DAD(Q) = "(NODE[Q+1]LSH -18)";
DEFINE SON(Q) = "(NODE[Q+1]LAND '777777)";
DEFINE ROW(Q) = "((NODE[Q+3]LSH -18)/64)";
DEFINE COL(Q) = "((NODE[Q+3]LAND '777777)/64)";
DEFINE ALT(Q) = "(NODE[Q+4]LSH -18)";
REAL SUBR AREA (ITG SHAPE); S⊂ MOVE 2,SHAPE;ADD 2,ORIG;HRLE 1,1(2);⊃;
REAL SUBR PERM (ITG SHAPE); S⊂ MOVE 2,SHAPE;ADD 2,ORIG;HLLE 1,1(2);⊃;
REAL SUBR PXY (ITG SHAPE); S⊂ MOVE 2,SHAPE;ADD 2,ORIG;HLLE 1,4(2);⊃;
REAL SUBR MXX (ITG SHAPE); S⊂ MOVE 2,SHAPE;ADD 2,ORIG;HLLE 1,6(2);⊃;
REAL SUBR MYY (ITG SHAPE); S⊂ MOVE 2,SHAPE;ADD 2,ORIG;HRLE 1,6(2);⊃;
REAL SUBR MZZ (ITG SHAPE); S⊂ MOVE 2,SHAPE;ADD 2,ORIG;HRLE 1,4(2);⊃;
REAL SUBR PHI (ITG S);
RETURN(0.5*ATAN2(MYY(S)-MXX(S),2*PXY(S)));
SUBR INERTIA;
BEGIN "INERTIA"
ITG I;
REAL A,X,Y,MX,MY,PR,C,S;
REAL A0,X0,Y0,MXX0,MYY0,PXY0;
REAL R1,R2,DR,C1,C2,DC;
α FIRST VERTEX;
A0←X0←Y0←MXX0←MYY0←PXY0←0; I←0;
R2 ← PRROW[1]; C2 ← PRCOL[1];
FOR I←16 STEP -1 UNTIL 1 DO
BEGIN
R1 ← R2; C1 ← C2;
R2 ← PRROW[I]; C2 ← PRCOL[I];
DR ← R2-R1; DC ← C2-C1;
α CONTRIBUTION OF TRIANGULAR PART;
A ← DC*DR/2; PR ← -A*A/18;
X ← (2*C2 + C1)/3; Y ← (2*R1 + C2)/3;
MX ← A*DR*DR/18; MY ← A*DC*DC/18;
α ACCUMULATE;
A0 ← A0 + A; PXY0 ← PXY0 + PR - X*Y*A;
X0 ← X0 + X*A; Y0 ← Y0 + Y*A;
MYY0 ← MYY0 + MY + X*X*A; MXX0 ← MXX0 + MX + Y*Y*A;
α CONTRIBUTION OF RECTANGULAR PART;
A ← DC*R1; PR ← 0;
X ← (C1+C2)/2; Y ← R1/2;
MX ← A*R1*R1/12; MY ← A*DC*DC/12;
α ACCUMULATE;
A0 ← A0 + A; PXY0 ← PXY0 + PR - X*Y*A;
X0 ← X0 + X*A; Y0 ← Y0 + Y*A;
MYY0 ← MYY0 + MY + X*X*A; MXX0 ← MXX0 + MX + Y*Y*A;
END;
ORBAREA ← A0;
ORBCOL ← X ← X0/A0;
ORBROW ← Y ← Y0/A0;
MXX0 ← MXX0/A0 - Y*Y;
MYY0 ← MYY0/A0 - X*X;
PXY0 ← PXY0/A0 + X*Y;
ORBARC ← 0.5*ATAN2(2*PXY0,MYY0-MXX0);
C ← COS(ORBARC); S ← SIN(ORBARC);
ORBMXX ← C*C*MXX0 + S*S*MYY0 - 2*C*S*PXY0;
ORBMYY ← C*C*MYY0 + S*S*MXX0 + 2*C*S*PXY0;
ORBPXY ← (C*C-S*S)*PXY0 + C*S*(MXX0 - MYY0);
ORBA ← 2*SQRT(ORBMYY);
ORBB ← ORBAREA/(π*ORBA);
BEGIN
ITG I,J;REAL QMAX, QMIN, Q;
QMAX ← 0; QMIN ← 999;
FOR I←1 THRU 8 DO
⊂ Q ← SQRT((PRROW[I]-PRROW[I+8])↑2 + (PRCOL[I]-PRCOL[I+8])↑2)/2;
IF Q>QMAX THEN QMAX ← Q;
IF Q<QMIN THEN QMIN ← Q;⊃;
OUTSTR(↓&↓&↓&↓&↓&↓&↓&↓);
OUTSTR(" ELLIPSE RADII = "&CVG(QMIN)&" "&CVG(QMAX)&↓);
OUTSTR(" ELLIPSE RADII = "&CVG(ORBB)&" "&CVG(ORBA)&↓);
QMIN ← 999;
FOR I←1 THRU 16 DO
IF QMIN>RADIUS[I] THEN ⊂ J←I;QMIN←RADIUS[I]; ⊃;
OUTSTR(CVS(J)&" PAN GUESS = "&
CVS(180*ATAN2(-XWC[J],YWC[J])/π+0.5)&↓);
END;
END "INERTIA";
SUBR PDPY (ITG PGN); α POLYGON DISPLAY;
BEGIN "PDPY"
REAL R,C,X,Y;
ITG V0,V,S;
α TEST SHAPE NODE FOR QUEUE BALL OUTLINE;
S ← ALT(PGN);
IF AREA(S)≤600 ∨ AREA(S)≥1500 THEN RETURN;
SNODE[CNT] ← S;
α SAVE & DISPLAY QUE BALL PROPERTIES;
R ← PRROW[CNT] ← ROW(S);
C ← PRCOL[CNT] ← COL(S);
PRXDC[CNT] ← X ← MAG*(C-CPA);
PRYDC[CNT] ← Y ← MAG*(RPA-R);
AIVECT(X,Y);DPYSST(CVS(CNT));
AIVECT(X-15,Y); AVECT(X+10,Y);
AIVECT(X,Y-15); AVECT(X,Y+10);
R ← RADIUS[CNT] ← SQRT(AREA(S)/π);
RETURN;
α POLYGONS PERMETER;
V ← V0 ← SON(PGN);
AIVECT(MAG*(COL(V)-144),MAG*(108-ROW(V)));
DO BEGIN
V ← CCW(V);AVECT(3.5*(COL(V)-144),3.5*(108-ROW(V)));
END UNTIL V=V0;
END "PDPY";
SUBR IDPY (ITG IMG); α IMAGE DISPLAY;
BEGIN "IDPY"
ITG L0,L,P0,P;
L0 ← L ← SON(IMG);
L ← CCW(L);
P0 ← P ← SON(L);
DO PDPY(P) UNTIL P0=(P←CCW(P));
END "IDPY";
α FILM DISPLAY;
SUBR FDPY;
BEGIN "FDPY"
ITG F,I0,I;
DPYSET(DPYBUF);CNT ← 0;
AIVECT(3.5*(000-144),3.5*(108-000));
AVECT(3.5*(288-144),3.5*(108-000));
AVECT(3.5*(288-144),3.5*(108-216));
AVECT(3.5*(000-144),3.5*(108-216));
AVECT(3.5*(000-144),3.5*(108-000));
DPYBIG(1);
F ← 0;I0 ← I ← SON(F);
DO ⊂ CNT←CNT+1;IDPY(I);⊃ UNTIL I0=(I←CCW(I));
DPYOUT(0);
END "FDPY";
α MAIN EXECUTION ----------------------------------------------------;
ARRYIN(1,NODE[1],SIZE-1);
ORIG ← LOCATION(NODE[0]);
RELEASE(1);OUTSTR(9&"EOF."&↓);
FDPY;
INERTIA;
α MAIN LOOP;
TRNDEL ← 2;
ROTDEL ← π/2;
WHILE TRUE DO
BEGIN
MKROT;
TRANSFORM;
SHOW;
MODIFY;
END;
END "MAIN"
END "QBALL";